home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0043_General Date Routines.pas < prev    next >
Pascal/Delphi Source File  |  1994-05-26  |  25KB  |  709 lines
  1. {$F+,O+,N+}
  2. UNIT Dates;
  3.  
  4.   { Version 1R0 - 1991 03 25                                               }
  5.   {         1R1 - 1991 04 09 - corrected several bugs, and                 }
  6.   {                          - deleted <JulianDa2>, <Da2OfWeek> and        }
  7.   {                            <JulianDa2ToDate> - all found to be not     }
  8.   {                            completely reliable.                        }
  9.  
  10. INTERFACE
  11.  
  12.   { These routines all assume that the year (y, y1) value is supplied in a }
  13.   { form that includes the century (i.e., in YYYY form).  No checking is   }
  14.   { performed to ensure that a month (m, m1) value is in the range 1..12   }
  15.   { or that a day (d, d1) value is in the range 1..28,29,30,31.  The       }
  16.   { FUNCTION ValidDate may be used to check for valid month and day        }
  17.   { parameters. FUNCTION DayOfYearToDate returns month and day (m, d) both }
  18.   { = 0 if the day-of-the-year (nd) is > 366 for a leap-year or > 365 for  }
  19.   { other years.                                                           }
  20.  
  21.   { NOTE: As written, FUNCTION Secs100 requires the presence of a 80x87    }
  22.   { co-processor.  Its declaration and implementation may be altered to    }
  23.   { REAL to make use of the floating-point emulation.                      }
  24.  
  25.   { Because the Gregorian calendar was not implemented in all countries at }
  26.   { the same time, these routines are not guaranteed to be valid for all   }
  27.   { dates. The real utility of these routines is that they will not fail   }
  28.   { on December 31, 1999 - as will many algorithms used in MIS programs    }
  29.   { implemented on mainframes.                                             }   
  30.  
  31.   { The routines are NOT highly optimized - I have tried to maintain the   }
  32.   { style of the algorithms presented in the sources I indicate. Any       }
  33.   { suggestions for algorithmic or code improvements will be gratefully    }
  34.   { accepted.  This implementation is in the public domain - no copyright  }
  35.   { is claimed.  No warranty either express or implied is given as to the  }
  36.   { correctness of the algorithms or their implementation.                 }
  37.  
  38.   { Author: Charles B. Chapman, London, Ontario, Canada [74370,516]        }
  39.   { Thanks to Leonard Erickson who supplied a test suite of values.        }
  40.  
  41.   FUNCTION IsLeap (y : WORD) : BOOLEAN;
  42.  
  43.   FUNCTION ValidDate (y, m, d : WORD) : BOOLEAN;
  44.   FUNCTION ValidDate_Str (Str         : string;                     {DWH}
  45.                           VAR Y, M, D : word;
  46.                           VAR Err_Str : string) : boolean;
  47.   FUNCTION ValidTime_Str (Str         : string;                     {DWH}
  48.                           VAR H, M, S : word;
  49.                           VAR Err_Str : string) : boolean;
  50.  
  51.   FUNCTION DayOfYear (y, m, d : WORD) : WORD;
  52.   FUNCTION JulianDay (y, m, d : WORD) : LONGINT;
  53.   FUNCTION JJ_JulianDay (y, m, d : word) : LONGINT;                 {DWH}
  54.  
  55.   FUNCTION DayOfWeek (y, m, d : WORD) : WORD;
  56.   FUNCTION DayOfWeek_Str (y, m, d : WORD) : String;                 {DWH}
  57.  
  58.   FUNCTION TimeStr   (h, m, s, c : WORD) : STRING;
  59.   FUNCTION TimeStr2  (h, m, s : WORD) : STRING;
  60.   FUNCTION SIDateStr (y, m, d : WORD; SLen : BYTE; FillCh : CHAR) : STRING;
  61.   FUNCTION MDYR_Str  (y, m, d : WORD): STRING;                      {DWH}
  62.  
  63.   FUNCTION Secs100 (h, m, s, c : WORD) : DOUBLE;
  64.   PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);
  65.  
  66.   PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);
  67.   PROCEDURE JJ_JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);  {DWH}
  68.  
  69.   PROCEDURE DateOfEaster (Yr : WORD; VAR Mo, Da : WORD);
  70.   PROCEDURE AddDays (y, m, d : WORD; plus : LONGINT; VAR y1, m1, d1 : WORD);
  71.  
  72.   FUNCTION Lotus_Date_Str (nd : LONGINT) : string;                  {DWH}
  73.   FUNCTION Str_Date_to_Lotus_Date_Format
  74.                      (Date       : String;
  75.                       VAR Err_Msg : String): LongInt;  {OLC}
  76. {==========================================================================}
  77.  
  78. IMPLEMENTATION
  79.   USES
  80.     Dos;
  81.  
  82. {==========================================================================}
  83.  
  84.   FUNCTION IsLeap (y : WORD) : BOOLEAN;
  85.  
  86.   { Returns TRUE if <y> is a leap-year                                     }
  87.  
  88.   BEGIN
  89.     IF y MOD 4 <> 0 THEN
  90.       IsLeap := FALSE
  91.     ELSE
  92.       IF y MOD 100 = 0 THEN
  93.         IF y MOD 400 = 0 THEN
  94.           IsLeap := TRUE
  95.         ELSE
  96.           IsLeap := FALSE
  97.       ELSE
  98.         IsLeap := TRUE
  99.   END;  { IsLeap }
  100.  
  101. {==========================================================================}
  102.  
  103.   FUNCTION DayOfYear (y, m, d : WORD) : WORD;
  104.  
  105.   { function IDAY from remark on CACM Algorithm 398                        }
  106.   { Computes day of the year for a given calendar date                     }
  107.   { GIVEN:   y - year                                                      }
  108.   {          m - month                                                     }
  109.   {          d - day                                                       }
  110.   { RETURNS: day-of-the-year (1..366, given valid input)                   }
  111.  
  112.   VAR
  113.     yy, mm, dd, Tmp1 : LONGINT;
  114.   BEGIN
  115.     yy := y;
  116.     mm := m;
  117.     dd := d;
  118.     Tmp1 := (mm + 10) DIV 13;
  119.     DayOfYear :=  3055 * (mm + 2) DIV 100 - Tmp1 * 2 - 91 +
  120.                   (1 - (yy - yy DIV 4 * 4 + 3) DIV 4 +
  121.                   (yy - yy DIV 100 * 100 + 99) DIV 100 -
  122.                   (yy - yy DIV 400 * 400 + 399) DIV 400) * Tmp1 + dd
  123.   END;  { DayOfYear }
  124.  
  125. {==========================================================================}
  126.  
  127.   FUNCTION JulianDay (y, m, d : WORD) : LONGINT;
  128.  
  129.   { procedure JDAY from CACM Alorithm 199                                  }
  130.   { Computes Julian day number for any Gregorian Calendar date             }
  131.   { GIVEN:   y - year                                                      }
  132.   {          m - month                                                     }
  133.   {          d - day                                                       }
  134.   { RETURNS: Julian day number (astronomically, for the day                }
  135.   {          beginning at noon) on the given date.                         }
  136.  
  137.   VAR
  138.     Tmp1, Tmp2, Tmp3, Tmp4, Tmp5 : LONGINT;
  139.   BEGIN
  140.     IF m > 2 THEN
  141.       BEGIN
  142.         Tmp1 := m - 3;
  143.         Tmp2 := y
  144.       END
  145.     ELSE
  146.       BEGIN
  147.         Tmp1 := m + 9;
  148.         Tmp2 := y - 1
  149.       END;
  150.     Tmp3 := Tmp2 DIV 100;
  151.     Tmp4 := Tmp2 MOD 100;
  152.     Tmp5 := d;
  153.     JulianDay := (146097 * Tmp3) DIV 4 + (1461 * Tmp4) DIV 4 +
  154.                  (153 * Tmp1 + 2) DIV 5 + Tmp5 + 1721119
  155.   END;  { JulianDay }
  156.  
  157. {==========================================================================}
  158.   
  159.   PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);
  160.                                                          
  161.   { procedure CALENDAR from CACM Algorithm 398                             }
  162.   { Computes month and day from given year and day of the year             }
  163.   { GIVEN:   nd - day-of-the-year (1..366)                                 }
  164.   {          y - year                                                      }
  165.   { RETURNS: m - month                                                     }
  166.   {          d - day                                                       }
  167.  
  168.   VAR
  169.     Tmp1, Tmp2, Tmp3, Tmp4, DaYr : LONGINT; 
  170.   BEGIN
  171.     DaYr := nd;
  172.     IF (DaYr = 366) AND (DayOfYear (y, 12, 31) <> 366) THEN
  173.       DaYr := 999;
  174.     IF DaYr <= 366 THEN
  175.       BEGIN
  176.         IF y MOD 4 = 0 THEN
  177.           Tmp1 := 1
  178.         ELSE
  179.           Tmp1 := 0;
  180.         IF (y MOD 400 = 0) OR (y MOD 100 <> 0) THEN
  181.           Tmp2 := Tmp1
  182.         ELSE
  183.           Tmp2 := 0;
  184.         Tmp1 := 0;
  185.         IF DaYr > Tmp2 + 59 THEN
  186.           Tmp1 := 2 - Tmp2;
  187.         Tmp3 := DaYr + Tmp1;
  188.         Tmp4 := ((Tmp3 + 91) * 100) DIV 3055;
  189.         d := ((Tmp3 + 91) - (Tmp4 * 3055) DIV 100);
  190.         m := (Tmp4 - 2)
  191.       END
  192.     ELSE
  193.       BEGIN
  194.         d := 0;
  195.         m := 0
  196.       END
  197.   END;  { DayOfYearToDate }
  198.  
  199. {==========================================================================}
  200.  
  201.   PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);
  202.  
  203.   { procedure JDATE from CACM Algorithm 199                                }
  204.   { Computes calendar date from a given Julian day number for any          }
  205.   { valid Gregorian calendar date                                          }
  206.   { GIVEN:   nd - Julian day number (2440000 --> 1968 5 23)                }
  207.   { RETURNS: y - year                                                      }
  208.   {          m - month                                                     }
  209.   {          d - day                                                       }
  210.  
  211.   VAR
  212.     Tmp1, Tmp2, Tmp3 : LONGINT;
  213.   BEGIN
  214.     Tmp1 := nd - 1721119;
  215.     Tmp3 := (4 * Tmp1 - 1) DIV 146097;
  216.     Tmp1 := (4 * Tmp1 - 1) MOD 146097;
  217.     Tmp2 := Tmp1 DIV 4;
  218.     Tmp1 := (4 * Tmp2 + 3) DIV 1461;
  219.     Tmp2 := (4 * Tmp2 + 3) MOD 1461;
  220.     Tmp2 := (Tmp2 + 4) DIV 4;
  221.     m := ((5 * Tmp2 - 3) DIV 153);
  222.     Tmp2 := (5 * Tmp2 - 3) MOD 153;
  223.     d := ((Tmp2 + 5) DIV 5);
  224.     y := (100 * Tmp3 + Tmp1);
  225.     IF m < 10 THEN
  226.       m := m + 3
  227.     ELSE
  228.       BEGIN
  229.         m := m - 9;
  230.         y := y + 1
  231.       END
  232.   END;  { JulianDayToDate }
  233.  
  234. {==========================================================================}
  235.  
  236.   PROCEDURE DateOfEaster (Yr : WORD; VAR Mo, Da : WORD);
  237.  
  238.   { Algorithm "E" from Knuth's "Art of Computer Programming", vol. 1       }
  239.   { Computes date of Easter for any year in the Gregorian calendar         }
  240.   { The local variables are the variable names used by Knuth.              }
  241.   { GIVEN:   Yr - year                                                     }
  242.   { RETURNS: Mo - month of Easter (3 or 4)                                 }
  243.   {          Da - day of Easter                                            }
  244.  
  245.   VAR
  246.     G, C, X, Z, D, E, N : LONGINT;
  247.   BEGIN
  248.   { Golden number of the year in Metonic cycle   }
  249.     G := Yr MOD 19 + 1;
  250.   { Century  }
  251.     C := Yr DIV 100 + 1;
  252.   { Corrections: }
  253.   { <X> is the no. of years in which leap-year was dropped in }
  254.   { order to keep step with the sun   }
  255.   { <Z> is a special correction to synchronize Easter with the }
  256.   { moon's orbit  . }
  257.     X := (3 * C) DIV 4 - 12;
  258.     Z := (8 * C + 5) DIV 25 - 5;
  259.   { <D> Find Sunday   }
  260.     D := (5 * Yr) DIV 4 - X - 10;
  261.   { Set Epact  }
  262.     E := (11 * G + 20 + Z - X) MOD 30;
  263.     IF E < 0 THEN
  264.       E := E + 30;
  265.     IF ((E = 25) AND (G > 11)) OR (E = 24) THEN
  266.       E := E + 1;
  267.   { Find full moon - the Nth of MARCH is a "calendar" full moon }
  268.     N := 44 - E;
  269.     IF N < 21 THEN
  270.       N := N + 30;
  271.   { Advance to Sunday }
  272.     N := N + 7 - ((D + N) MOD 7);
  273.   { Get Month and Day }
  274.     IF N > 31 THEN
  275.       BEGIN
  276.         Mo := 4;
  277.         Da := N - 31
  278.       END
  279.     ELSE
  280.       BEGIN
  281.         Mo := 3;
  282.         Da := N
  283.       END
  284.   END; { DateOfEaster }
  285.  
  286. {==========================================================================}
  287.  
  288.   FUNCTION SIDateStr (y, m, d : WORD; SLen : BYTE; FillCh : CHAR) : STRING;
  289.  
  290.   { Returns date <y>, <m>, <d> converted to a string in SI format.  If     }
  291.   { <Slen> = 10, the string is in form YYYY_MM_DD; If <SLen> = 8, in form  }
  292.   { YY_MM_DD; otherwise a NULL string is returned.  The character between  }
  293.   { values is <FillCh>.                                                    }
  294.   { For correct Systeme-Internationale date format, the call should be:    }
  295.   {   SIDateStr (Year, Month, Day, 10, ' ');                               }
  296.   { IF <y>, <m> & <d> are all = 0, Runtime library PROCEDURE GetDate is    }
  297.   { called to obtain the current date.                                     }
  298.  
  299.   VAR
  300.     s2 : STRING[2];
  301.     s4 : STRING[4];
  302.     DStr : STRING[10];
  303.     Index : BYTE;
  304.     dw : WORD;
  305.   BEGIN
  306.     IF (SLen <> 10) AND (SLen <> 8) THEN
  307.       DStr[0] := Chr (0)
  308.     ELSE
  309.       BEGIN
  310.         IF (y = 0) AND (m = 0) AND (d = 0) THEN
  311.           GetDate (y, m, d, dw);
  312.         IF SLen = 10 THEN
  313.           BEGIN
  314.             Str (y:4, s4);
  315.             DStr[1] := s4[1];
  316.             DStr[2] := s4[2];
  317.             DStr[3] := s4[3];
  318.             DStr[4] := s4[4];
  319.             Index := 5
  320.           END
  321.         ELSE
  322.           IF SLen = 8 THEN
  323.             BEGIN
  324.               Str (y MOD 100:2, s2);
  325.               DStr[1] := s2[1];
  326.               DStr[2] := s2[2];
  327.               Index := 3
  328.             END;
  329.         DStr[Index] := FillCh;
  330.         Inc (Index);
  331.         Str (m:2, s2);
  332.         IF s2[1] = ' ' THEN
  333.           DStr[Index] := '0'
  334.         ELSE
  335.           DStr[Index] := s2[1];
  336.         DStr[Index+1] := s2[2];
  337.         Index := Index + 2;
  338.         DStr[Index] := FillCh;
  339.         Inc (Index);
  340.         Str (d:2, s2);
  341.         IF s2[1] = ' ' THEN
  342.           DStr[Index] := '0'
  343.         ELSE
  344.           DStr[Index] := s2[1];
  345.         DStr[Index+1] := s2[2];
  346.         DStr[0] := Chr (SLen)
  347.       END;
  348.     SIDateStr := DStr
  349.   END;  { SIDateStr }
  350.  
  351. {==========================================================================}
  352.  
  353.   FUNCTION TimeStr (h, m, s, c : WORD) : STRING;
  354.  
  355.   { Returns the time <h>, <m>, <s> and <c> formatted in a string:          }
  356.   { "HH:MM:SS.CC"                                                          }
  357.   { This function does NOT check for valid string length.                  }
  358.   {                                                                        }
  359.   { IF <h>, <m>, <s> & <c> all = 0, the Runtime PROCEDURE GetTime is       }
  360.   { called to get the current time.                                        }
  361.  
  362.   VAR
  363.     sh, sm, ss, sc : STRING[2];
  364.   BEGIN
  365.     IF h + m + s + c = 0 THEN
  366.       GetTime (h, m, s, c);
  367.     Str (h:2, sh);
  368.     IF sh[1] = ' ' THEN
  369.       sh[1] := '0';
  370.     Str (m:2, sm);
  371.     IF sm[1] = ' ' THEN
  372.       sm[1] := '0';
  373.     Str (s:2, ss);
  374.     IF ss[1] = ' ' THEN
  375.       ss[1] := '0';
  376.     Str (c:2, sc);
  377.     IF sc[1] = ' ' THEN
  378.       sc[1] := '0';
  379.     TimeStr := Concat (sh, ':', sm, ':', ss, '.', sc)
  380.   END;  { TimeStr }
  381.  
  382. {==========================================================================}
  383.   FUNCTION TimeStr2 (h, m, s : WORD) : STRING;
  384.  
  385.   { Returns the time <h>, <m>, and <s>  formatted in a string:             }
  386.   { "HH:MM:SS"                                                             }
  387.   { This function does NOT check for valid string length.                  }
  388.   {                                                                        }
  389.   { IF <h>, <m>, & <c> all = 0, the Runtime PROCEDURE GetTime is           }
  390.   { called to get the current time.                                        }
  391.  
  392.   VAR
  393.     c              : word;
  394.     sh, sm, ss     : STRING[2];
  395.   BEGIN
  396.     IF h + m + s = 0 THEN
  397.       GetTime (h, m, s, c);
  398.     Str (h:2, sh);
  399.     IF sh[1] = ' ' THEN
  400.       sh[1] := '0';
  401.     Str (m:2, sm);
  402.     IF sm[1] = ' ' THEN
  403.       sm[1] := '0';
  404.     Str (s:2, ss);
  405.     IF ss[1] = ' ' THEN
  406.       ss[1] := '0';
  407.     TimeStr2 := Concat (sh, ':', sm, ':', ss)
  408.   END;  { TimeStr2 }
  409.  
  410. {==========================================================================}
  411.   FUNCTION MDYR_Str (y, m, d : WORD): STRING;     {dwh}
  412.  
  413.   { Returns the date <y>, <m>, <d> formatted in a string:                  }
  414.   { "MM/DD/YYYY"                                                           }
  415.   { This function does NOT check for valid string length.                  }
  416.   {                                                                        }
  417.   { IF <m>, <d>, & <y> all = 0, the Runtime PROCEDURE GetDate is           }
  418.   { called to get the current date.                                        }
  419.  
  420.   VAR
  421.     sm, sd     : STRING[2];
  422.     sy         : STRING[4];
  423.     dont_care  : word;
  424.   BEGIN
  425.     IF y + m + d = 0 THEN
  426.       GetDate (y, m, d, dont_care);
  427.     Str (m:2, sm);
  428.     IF sm[1] = ' ' THEN
  429.       sm[1] := '0';
  430.     Str (d:2, sd);
  431.     IF sd[1] = ' ' THEN
  432.       sd[1] := '0';
  433.     Str (y:4, sy);
  434.     MDYR_Str := Concat (sm, '/', sd, '/', sy)
  435.   END;  { MDYR_Str }
  436.  
  437.  
  438. {==========================================================================}
  439.  
  440.   FUNCTION Secs100 (h, m, s, c : WORD) : DOUBLE;
  441.  
  442.   { Returns the given time <h>, <m>, <s> and <c> as a floating-point       }
  443.   { value in seconds (presumably valid to .01 of a second).                }
  444.   {                                                                        }
  445.   { IF <h>, <m>, <s> & <c> all = 0, the Runtime PROCEDURE GetTime is       }
  446.   { called to get the current time.                                        }
  447.  
  448.   BEGIN
  449.     IF h + m + s + c = 0 THEN
  450.       GetTime (h, m, s, c);
  451.     Secs100 :=  (h * 60.0 + m) * 60.0 + s + (c * 0.01)
  452.   END;  { Secs100 }
  453.  
  454.  
  455. {==========================================================================}
  456.  
  457.   PROCEDURE AddDays (y, m, d : WORD; plus : LONGINT; VAR y1, m1, d1 : WORD);
  458.  
  459.   { Computes the date <y1>, <m1>, <d1> resulting from the addition of      }
  460.   { <plus> days to the calendar date <y>, <m>, <d>.                        }
  461.  
  462.   VAR
  463.     JulDay : LONGINT;
  464.   BEGIN
  465.     JulDay := JulianDay (y, m, d) + plus;
  466.     JulianDayToDate (JulDay, y1, m1, d1)
  467.   END;  { AddDays }
  468.  
  469. {==========================================================================}
  470.  
  471.   FUNCTION ValidDate (y, m, d : WORD) : BOOLEAN;
  472.  
  473.   { Returns TRUE if the date <y> <m> <d> is valid.                         }
  474.  
  475.   VAR
  476.     JulDay : LONGINT;
  477.     ycal, mcal, dcal : WORD;
  478.   BEGIN
  479.     JulDay := JulianDay (y, m, d);
  480.     JulianDayToDate (JulDay, ycal, mcal, dcal);
  481.     ValidDate := (y = ycal) AND (m = mcal) AND (d = dcal)
  482.   END;  { ValidDate }
  483.  
  484. {==========================================================================}
  485.  
  486.   FUNCTION DayOfWeek (y, m, d : WORD) : WORD;
  487.  
  488.   { Returns the Day-of-the-week (0 = Sunday) (Zeller's congruence) from an }
  489.   { algorithm IZLR given in a remark on CACM Algorithm 398.                }
  490.  
  491.   VAR
  492.     Tmp1, Tmp2, yy, mm, dd : LONGINT;
  493.   BEGIN
  494.     yy := y;
  495.     mm := m;
  496.     dd := d;
  497.     Tmp1 := mm + 10;
  498.     Tmp2 := yy + (mm - 14) DIV 12;
  499.     DayOfWeek :=  ((13 *  (Tmp1 - Tmp1 DIV 13 * 12) - 1) DIV 5 +
  500.                   dd + 77 + 5 * (Tmp2 - Tmp2 DIV 100 * 100) DIV 4 +
  501.                   Tmp2 DIV 400 - Tmp2 DIV 100 * 2) MOD 7;
  502.   END;  { DayOfWeek }
  503.  
  504. {==========================================================================}
  505. FUNCTION DayOfWeek_Str (y, m, d : WORD) : String;
  506. begin
  507.   CASE DayOfWeek (y, m, d) of
  508.    0: DayOfWeek_Str := 'SUNDAY';
  509.    1: DayOfWeek_Str := 'MONDAY';
  510.    2: DayOfWeek_Str := 'TUESDAY';
  511.    3: DayOfWeek_Str := 'WEDNESDAY';
  512.    4: DayOfWeek_Str := 'THURSDAY';
  513.    5: DayOfWeek_Str := 'FRIDAY';
  514.    6: DayOfWeek_Str := 'SATURDAY';
  515.   end; {case}
  516. end; {dayofweek_str}
  517.  
  518.  
  519. {==========================================================================}
  520. FUNCTION JJ_JulianDay (y, m, d : word) : LONGINT;
  521.   {*  format     5 position = last 2 digits of year+DayOfYear *}
  522. var
  523.   dw : word;
  524. begin
  525.   IF (y+m+d = 0)
  526.     THEN GetDate (Y,M,D, dw);
  527.   JJ_JulianDay:= ((LongInt(y) Mod 100)*1000+ DayOfYear(y,m,d));
  528. end; {jj_julianday}
  529.  
  530.  
  531. {==========================================================================}
  532. PROCEDURE JJ_JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);
  533.   {*  format     nd=5 positions   last 2 digits of year+DayOfYear *}
  534. BEGIN
  535.   y := (nd DIV 1000); {year}
  536.   IF (y < 60)          {will error when 2060}
  537.     THEN y := 2000+y
  538.     ELSE y := 1900+y;
  539.                     {dayofyear}
  540.   DayOfYearToDate ( (nd MOD 1000), y, m, d);
  541. END;  { JulianDayToDate }
  542.  
  543. {==========================================================================}
  544. FUNCTION Lotus_Date_Str (nd : LONGINT) : string;
  545.    {* lotus is strange the ND is the number of days SINCE 12/31/1899 *}
  546.    {*         which is the JULIAN day 2415020                        *}
  547.    {*   Return format is MM/DD/YYYY                                  *}
  548. var
  549.   y,m,d : word;
  550. begin
  551.   JulianDayToDate (nd+2415020-1, y,m,d);
  552.   Lotus_Date_Str := MDYr_Str (y,m,d);
  553. end; {lotus_date_str}
  554.  
  555. {==========================================================================}
  556. FUNCTION Str_Date_to_Lotus_Date_Format( Date        : String;
  557.                                         VAR Err_Msg : String): LongInt;{OLC}
  558. VAR
  559.   Y, M, D : word;
  560.   Julian  : LongInt;
  561. BEGIN
  562.   Err_Msg := '';
  563.   IF ValidDate_Str(Date, Y, M, D, Err_Msg ) THEN
  564.     BEGIN
  565.       Julian := JulianDay( Y, M, D );
  566.       Julian := Julian - 2415020 + 1;
  567.       Str_Date_to_Lotus_Date_Format := Julian
  568.     END
  569.   ELSE
  570.     Str_Date_to_Lotus_Date_Format := -1;
  571. END;{Str_Date_to_Lotus_Date_Format}
  572.  
  573.  
  574. {==========================================================================}
  575. FUNCTION ValidDate_Str (Str         : string;
  576.                         VAR Y, M, D : word;
  577.                         VAR Err_Str : string) : boolean;
  578.    {* returns TRUE when Str is valid  MM/DD/YYYY  or MM-DD-YYYY      *}
  579.    {*         the values are ranged checked and the date is also     *}
  580.    {*         checked for existance                                  *}
  581.    {*         Y, M, D are filled in with the values.                 *}
  582. var
  583.   Err_Code               : integer;
  584.   Long_Int               : LongInt;
  585.   Slash1, Slash2         : byte;
  586. begin
  587.   Err_Str  := '';
  588.   Err_Code := 0;
  589.  
  590.   IF (Length (Str) < 8)
  591.     THEN Err_Str := 'Date must be   12/31/1999  format'
  592.   ELSE
  593.     BEGIN
  594.       Slash1 := POS ('/', Str);
  595.       IF (Slash1 > 0)
  596.         THEN Slash2 := POS ('/', COPY (Str, Slash1+1, LENGTH(Str))) + Slash1
  597.       ELSE
  598.         BEGIN
  599.           Slash2 := 0;
  600.           Slash1 := POS ('-', Str);
  601.           IF (Slash1 > 0)
  602.             THEN Slash2 := POS ('-', COPY (Str, Slash1+1,
  603.                                              LENGTH(Str))) + Slash1;
  604.         END;
  605.  
  606.       IF ((Slash1 =  Slash2) or (Slash2 = 0))
  607.         THEN Err_Str := 'Date String must have either "-" or "/"'+
  608.                         ' such as (12/01/1999)'
  609.       ELSE
  610.         BEGIN
  611.           VAL (COPY(Str, 1,(Slash1-1)), Long_Int, Err_Code);
  612.           IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 12))
  613.             THEN Err_Str := 'Month must be a number 1..12!'
  614.  
  615.           ELSE
  616.             BEGIN
  617.               M := Long_Int;
  618.               VAL (COPY(Str, (Slash1+1),(Slash2-Slash1-1)),
  619.                            Long_Int, Err_Code);
  620.               IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 31))
  621.                 THEN Err_Str := 'Day must be a number 1..31!'
  622.  
  623.               ELSE
  624.                 BEGIN
  625.                   D := Long_Int;
  626.                   VAL (COPY(Str, (Slash2+1),LENGTH(Str)), Long_Int, Err_Code);
  627.                   IF ((Err_Code <> 0) or (Long_Int < 1900))
  628.                     THEN Err_Str := 'Year must be a number greater than 1900!'
  629.                     ELSE Y := Long_Int;
  630.                 END;
  631.             END;
  632.         END;
  633.     END; {if long enough}
  634.  
  635.   IF ((LENGTH(Err_Str) = 0) and (NOT DATES.ValidDate (Y, M, D)))
  636.     THEN Err_Str := 'Date does not exist!!!!';
  637.  
  638.   IF (LENGTH(Err_Str) = 0)
  639.     THEN ValidDate_Str := TRUE
  640.     ELSE ValidDate_Str := FALSE;
  641.  
  642. END; {validdate_str}
  643.  
  644. {==========================================================================}
  645. FUNCTION ValidTime_Str (Str         : string;
  646.                         VAR H, M, S : word;
  647.                         VAR Err_Str : string) : boolean;
  648.    {* returns TRUE when Str is valid  HH:MM  or HH:MM:SS             *}
  649.    {*         also H, M, S are filled in with the values.            *}
  650. var
  651.   Err_Code               : integer;
  652.   Long_Int               : LongInt;{use longint with VAL to prevent overflow}
  653.   Sep1, Sep2             : byte;
  654.   Count                  : byte;
  655. begin
  656.   Err_Str  := '';
  657.   Err_Code := 0;
  658.  
  659.   IF (Length (Str) < 4)
  660.     THEN Err_Str := 'Time must be   HH:MM or HH:MM:SS  format'
  661.   ELSE
  662.     BEGIN
  663.       Sep1 := POS (':', Str);
  664.       IF (Sep1 = 0)
  665.         THEN Err_Str := 'Time String must have either ":" '+
  666.                         ' such as  HH:MM  or  HH:MM:SS'
  667.  
  668.       ELSE
  669.         BEGIN
  670.           VAL (COPY(Str, 1,(Sep1-1)), Long_Int, Err_Code);
  671.           IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 24))
  672.             THEN Err_Str := 'Hour must be a number 1..24!'
  673.  
  674.           ELSE
  675.             BEGIN
  676.               H := Long_Int;
  677.               Sep2 := POS (':', COPY (Str, Sep1+1, LENGTH(Str))) + Sep1;
  678.               IF (Sep2 = Sep1)
  679.                 THEN Count := LENGTH(Str)
  680.                 ELSE Count := Sep2-Sep1-1;
  681.               VAL (COPY(Str,(Sep1+1),Count), Long_Int, Err_Code);
  682.               IF ((Err_Code <> 0) or (Long_Int < 0) or (Long_Int > 59))
  683.                 THEN Err_Str := 'Minute must be a number 0..59!'
  684.  
  685.               ELSE
  686.                 BEGIN
  687.                   M := Long_Int;
  688.                   IF (Sep2 <> Sep1) THEN
  689.                     BEGIN
  690.                       VAL (COPY(Str, (Sep2+1),LENGTH(Str)), Long_Int, Err_Code);
  691.                       IF ((Err_Code <> 0) or (Long_Int < 0) or (Long_Int > 59))
  692.                         THEN Err_Str := 'Second must be a number 0..59!'
  693.                         ELSE S := Long_Int;
  694.                     END
  695.                   ELSE S := 0;
  696.                 END;
  697.             END;
  698.         END;
  699.     END; {if long enough}
  700.  
  701.   IF (LENGTH(Err_Str) = 0)
  702.     THEN ValidTime_Str := TRUE
  703.     ELSE ValidTime_Str := FALSE;
  704.  
  705. END; {validtime_str}
  706.  
  707. END. {unit dates}
  708.  
  709.